home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH3 / SRC / DEVINFO.FRM < prev    next >
Text File  |  1996-01-09  |  11KB  |  286 lines
  1. VERSION 4.00
  2. Begin VB.Form DevInfoForm 
  3.    Caption         =   "DevInfo"
  4.    ClientHeight    =   3630
  5.    ClientLeft      =   1320
  6.    ClientTop       =   1320
  7.    ClientWidth     =   5055
  8.    Height          =   4320
  9.    Left            =   1260
  10.    LinkTopic       =   "PalInfo"
  11.    ScaleHeight     =   242
  12.    ScaleMode       =   3  'Pixel
  13.    ScaleWidth      =   337
  14.    Top             =   690
  15.    Width           =   5175
  16.    Begin VB.TextBox InfoText 
  17.       Height          =   3615
  18.       Left            =   0
  19.       MultiLine       =   -1  'True
  20.       ScrollBars      =   2  'Vertical
  21.       TabIndex        =   0
  22.       Top             =   0
  23.       Width           =   5055
  24.    End
  25.    Begin VB.Menu mnuFile 
  26.       Caption         =   "&File"
  27.       Begin VB.Menu mnuFileExit 
  28.          Caption         =   "E&xit"
  29.       End
  30.    End
  31. End
  32. Attribute VB_Name = "DevInfoForm"
  33. Attribute VB_Creatable = False
  34. Attribute VB_Exposed = False
  35. Option Explicit
  36.  
  37. Private Sub Form_Load()
  38. Dim txt As String
  39. Dim sys_pal_size As Integer
  40. Dim num_static As Integer
  41. Dim clrres As Integer
  42. Dim rascaps As Integer
  43. Dim curves As Integer
  44. Dim lines As Integer
  45. Dim poly As Integer
  46. Dim text As Integer
  47.  
  48.     ' Get the device type.
  49.     txt = "This device is a "
  50.     Select Case GetDeviceCaps(hDC, TECHNOLOGY)
  51.         Case DT_PLOTTER
  52.             txt = txt & "vector plotter"
  53.         Case DT_RASDISPLAY
  54.             txt = txt & "raster display"
  55.         Case DT_RASPRINTER
  56.             txt = txt & "raster printer"
  57.         Case DT_RASCAMERA
  58.             txt = txt & "raster camera"
  59.         Case DT_CHARSTREAM
  60.             txt = txt & "character-stream, PLP"
  61.         Case DT_METAFILE
  62.             txt = txt & "metafile, VDM"
  63.         Case DT_DISPFILE
  64.             txt = txt & "display-file"
  65.     End Select
  66.     txt = txt & "." & vbCrLf
  67.     
  68.     ' Get the display size in millimeters.
  69.     txt = txt & "The display is" & _
  70.         Str$(GetDeviceCaps(hDC, HORZSIZE)) & "x" & _
  71.         Format$(GetDeviceCaps(hDC, VERTSIZE))
  72.     
  73.     ' Get the display size in pixels.
  74.     txt = txt & " millimeters or" & _
  75.         Str$(GetDeviceCaps(hDC, HORZRES)) & "x" & _
  76.         Format$(GetDeviceCaps(hDC, VERTRES)) & _
  77.         " pixels." & vbCrLf
  78.     
  79.     ' Get logical pixels per inch.
  80.     txt = txt & "Horizontal pixels per inch:" & _
  81.         Str$(GetDeviceCaps(hDC, LOGPIXELSX)) & _
  82.         vbCrLf
  83.     txt = txt & "Vertical pixels per inch:" & _
  84.         Str$(GetDeviceCaps(hDC, LOGPIXELSY)) & _
  85.         vbCrLf
  86.         
  87.     ' Get color and tool information.
  88.     txt = txt & "Bits per pixel:" & _
  89.         Str$(GetDeviceCaps(hDC, BITSPIXEL)) & _
  90.         "." & vbCrLf
  91.     txt = txt & "Color planes:" & _
  92.         Str$(GetDeviceCaps(hDC, PLANES)) & _
  93.         "." & vbCrLf
  94.     txt = txt & "Device brushes:" & _
  95.         Str$(GetDeviceCaps(hDC, NUMBRUSHES)) & _
  96.         "." & vbCrLf
  97.     txt = txt & "Device colors:" & _
  98.         Str$(GetDeviceCaps(hDC, NUMCOLORS)) & _
  99.         "." & vbCrLf
  100.     txt = txt & "Device fonts:" & _
  101.         Str$(GetDeviceCaps(hDC, NUMFONTS)) & _
  102.         "." & vbCrLf
  103.     txt = txt & "Device markers:" & _
  104.         Str$(GetDeviceCaps(hDC, NUMMARKERS)) & _
  105.         "." & vbCrLf
  106.     txt = txt & "Device pens:" & _
  107.         Str$(GetDeviceCaps(hDC, NUMPENS)) & _
  108.         "." & vbCrLf
  109.     
  110.     ' See if the screen supports palettes.
  111.     rascaps = GetDeviceCaps(hDC, RASTERCAPS)
  112.     If rascaps And RC_PALETTE Then
  113.         txt = txt & "This device supports palettes." & vbCrLf
  114.         
  115.         ' See how big the system palette is.
  116.         sys_pal_size = GetDeviceCaps(hDC, SIZEPALETTE)
  117.         txt = txt & "The system palette holds" & _
  118.             Str$(sys_pal_size) & " entries." & _
  119.             vbCrLf
  120.         
  121.         ' See how many static colors there are.
  122.         num_static = GetDeviceCaps(hDC, NUMRESERVED)
  123.         txt = txt & "There are" & Str$(num_static) & _
  124.             " static colors." & vbCrLf
  125.         
  126.         ' Give the indexes of the static colors.
  127.         txt = txt & "The static colors are in system palette entries: 0-" & _
  128.             Format$(num_static \ 2 - 1) & " and " & _
  129.             Format$(sys_pal_size - num_static \ 2) & _
  130.             "-" & Format$(sys_pal_size - 1) & _
  131.             "." & vbCrLf
  132.     
  133.         ' Get the color resolution.
  134.         clrres = GetDeviceCaps(hDC, COLORRES)
  135.         txt = txt & "The color resolution is" & _
  136.             Str$(clrres) & " bits per pixel (" & _
  137.             Format$(2 ^ clrres) & _
  138.             " possible values)." & vbCrLf
  139.     
  140.         ' Get RASTERCAPS values.
  141.         txt = txt & "This device supports the following raster features:" & _
  142.             vbCrLf
  143.         If rascaps And RC_BANDING Then _
  144.             txt = txt & "    Banding." & vbCrLf
  145.         If rascaps And RC_BIGFONT Then _
  146.             txt = txt & "    Fonts bigger than 64K." & vbCrLf
  147.         If rascaps And RC_BITBLT Then _
  148.             txt = txt & "    Bitmap transfer." & vbCrLf
  149.         If rascaps And RC_BITMAP64 Then _
  150.             txt = txt & "    Bitmaps bigger than 64K." & vbCrLf
  151.         If rascaps And RC_DI_BITMAP Then _
  152.             txt = txt & "    The SetDIBits and GetDIBits functions." & vbCrLf
  153.         If rascaps And RC_DIBTODEV Then _
  154.             txt = txt & "    The SetDIBitsToDevice function." & vbCrLf
  155.         If rascaps And RC_FLOODFILL Then _
  156.             txt = txt & "    Flood fills." & vbCrLf
  157.         If rascaps And RC_GDI20_OUTPUT Then _
  158.             txt = txt & "    Windows 2.0 features." & vbCrLf
  159.         If rascaps And RC_PALETTE Then _
  160.             txt = txt & "    Palettes." & vbCrLf
  161.         If rascaps And RC_SCALING Then _
  162.             txt = txt & "    Scaling." & vbCrLf
  163.         If rascaps And RC_STRETCHBLT Then _
  164.             txt = txt & "    The StretchBlt function." & vbCrLf
  165.         If rascaps And RC_STRETCHDIB Then _
  166.             txt = txt & "    The StretchDIBits function." & vbCrLf
  167.             
  168.         ' Get CURVECAPS values.
  169.         curves = GetDeviceCaps(hDC, CURVECAPS)
  170.         txt = txt & "This device supports the following curve features:" & _
  171.             vbCrLf
  172.         If curves And CC_CHORD Then _
  173.             txt = txt & "    Chords." & vbCrLf
  174.         If curves And CC_CIRCLES Then _
  175.             txt = txt & "    Circles." & vbCrLf
  176.         If curves And CC_ELLIPSES Then _
  177.             txt = txt & "    Ellipses." & vbCrLf
  178.         If curves And CC_INTERIORS Then _
  179.             txt = txt & "    Interiors." & vbCrLf
  180.         If curves And CC_PIE Then _
  181.             txt = txt & "    Pie slices." & vbCrLf
  182.         If curves And CC_STYLED Then _
  183.             txt = txt & "    Line styles." & vbCrLf
  184.         If curves And CC_WIDE Then _
  185.             txt = txt & "    Wide lines." & vbCrLf
  186.         If curves And CC_WIDESTYLED Then _
  187.             txt = txt & "    Wide styled lines." & vbCrLf
  188.  
  189.         ' Get LINECAPS values.
  190.         lines = GetDeviceCaps(hDC, LINECAPS)
  191.         txt = txt & "This device supports the following line features:" & _
  192.             vbCrLf
  193.         If lines And LC_INTERIORS Then _
  194.             txt = txt & "    Interiors." & vbCrLf
  195.         If lines And LC_MARKER Then _
  196.             txt = txt & "    Markers." & vbCrLf
  197.         If lines And LC_POLYLINE Then _
  198.             txt = txt & "    Polyline." & vbCrLf
  199.         If lines And LC_POLYMARKER Then _
  200.             txt = txt & "    Polymarkers." & vbCrLf
  201.         If lines And LC_STYLED Then _
  202.             txt = txt & "    Styled lines." & vbCrLf
  203.         If lines And LC_WIDE Then _
  204.             txt = txt & "    Wide lines." & vbCrLf
  205.         If lines And LC_WIDESTYLED Then _
  206.             txt = txt & "    Wide styled lines." & vbCrLf
  207.  
  208.         ' Get POLYGONALCAPS values.
  209.         poly = GetDeviceCaps(hDC, POLYGONALCAPS)
  210.         txt = txt & "This device supports the following polygon features:" & _
  211.             vbCrLf
  212.         If lines And PC_INTERIORS Then _
  213.             txt = txt & "    Interiors." & vbCrLf
  214.         If lines And PC_POLYGON Then _
  215.             txt = txt & "    Alternate filled polygons." & vbCrLf
  216.         If lines And PC_RECTANGLE Then _
  217.             txt = txt & "    Rectangles." & vbCrLf
  218.         If lines And PC_SCANLINE Then _
  219.             txt = txt & "    Scan lines." & vbCrLf
  220.         If lines And PC_STYLED Then _
  221.             txt = txt & "    Styled borders." & vbCrLf
  222.         If lines And PC_WIDE Then _
  223.             txt = txt & "    Wide borders." & vbCrLf
  224.         If lines And PC_WIDESTYLED Then _
  225.             txt = txt & "    Wide styled borders." & vbCrLf
  226.         If lines And PC_WINDPOLYGON Then _
  227.             txt = txt & "    Winding number filled polygons." & vbCrLf
  228.  
  229.         ' Get TEXTCAPS values.
  230.         text = GetDeviceCaps(hDC, TEXTCAPS)
  231.         txt = txt & "This device supports the following text features:" & _
  232.             vbCrLf
  233.         If lines And TC_CP_STROKE Then _
  234.             txt = txt & "    Stroke clip precision." & vbCrLf
  235.         If lines And TC_CR_90 Then _
  236.             txt = txt & "    Characters rotated 90 degrees." & vbCrLf
  237.         If lines And TC_CR_ANY Then _
  238.             txt = txt & "    Characters rotated through any angle." & vbCrLf
  239.         If lines And TC_EA_DOUBLE Then _
  240.             txt = txt & "    Double weight fonts (bold)." & vbCrLf
  241.         If lines And TC_IA_ABLE Then _
  242.             txt = txt & "    Italics." & vbCrLf
  243.         If lines And TC_OP_CHARACTER Then _
  244.             txt = txt & "    Character output precision." & vbCrLf
  245.         If lines And TC_OP_STROKE Then _
  246.             txt = txt & "    Stroke output precision." & vbCrLf
  247.         If lines And TC_RA_ABLE Then _
  248.             txt = txt & "    Raster fonts." & vbCrLf
  249.         If lines And TC_SA_CONTIN Then _
  250.             txt = txt & "    Fonts scaled by any factor." & vbCrLf
  251.         If lines And TC_SA_DOUBLE Then _
  252.             txt = txt & "    Font scaled by a factor of 2." & vbCrLf
  253.         If lines And TC_SA_INTEGER Then _
  254.             txt = txt & "    Fonts scaled by integer multiples." & vbCrLf
  255.         If lines And TC_SF_X_YINDEP Then _
  256.             txt = txt & "    Fonts scaled in the X and Y directions independently." & vbCrLf
  257.         If lines And TC_SO_ABLE Then _
  258.             txt = txt & "    Strikeout." & vbCrLf
  259.         If lines And TC_UA_ABLE Then _
  260.             txt = txt & "    Underline." & vbCrLf
  261.         If lines And TC_VA_ABLE Then _
  262.             txt = txt & "    Vector fonts." & vbCrLf
  263.  
  264.     Else
  265.         txt = txt & "This device does not support palettes." & vbCrLf
  266.     End If
  267.  
  268.     InfoText.text = txt
  269. End Sub
  270.  
  271. ' ***********************************************
  272. ' Make the text box as large as possible.
  273. ' ***********************************************
  274. Private Sub Form_Resize()
  275.     If WindowState = vbMinimized Then Exit Sub
  276.     
  277.     InfoText.Move 0, 0, ScaleWidth, ScaleHeight
  278. End Sub
  279.  
  280. Private Sub mnuFileExit_Click()
  281.     Unload Me
  282. End Sub
  283.  
  284.  
  285.  
  286.